home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / module-language.scm < prev    next >
Text File  |  1995-10-13  |  6KB  |  230 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; The DEFINE-INTERFACE and DEFINE-STRUCTURE macros.
  5.  
  6. (define-syntax def
  7.   (syntax-rules ()
  8.     ((def (?name . ?args) ?body ...)
  9.      (really-def () ?name (lambda ?args ?body ...)))
  10.     ((def ?name ...)
  11.      (really-def () ?name ...))))
  12.  
  13. (define-syntax really-def
  14.   (syntax-rules ()
  15.     ((really-def (?name ...) ?exp)
  16.      (define-multiple (?name ...)
  17.        (begin (verify-later! (lambda () ?name))
  18.           ...
  19.           ?exp)))
  20.     ((really-def (?name ...) ?name1 ?etc ...)
  21.      (really-def (?name ... ?name1) ?etc ...))))
  22.  
  23. (define-syntax define-multiple
  24.   (syntax-rules ()
  25.     ((define-multiple (?name) ?exp)
  26.      (define ?name (note-name! ?exp '?name)))
  27.     ((define-multiple (?name ...) ?exp)
  28.      (begin (define ?name)
  29.         ...
  30.         (let ((frob (lambda things
  31.               (begin (set! ?name
  32.                        (note-name! (car things) '?name))
  33.                  (set! things (cdr things)))
  34.               ...)))
  35.           (call-with-values (lambda () ?exp) frob))))))
  36.  
  37.  
  38. ; Interfaces
  39.  
  40. ; <definition> ::= (define-interface <name> <int>)
  41. ; <int> ::= <name> | (export <item> ...) | (compound-interface <int> ...)
  42.  
  43. (define-syntax define-interface
  44.   (syntax-rules ()
  45.     ((define-interface ?name ?int)
  46.      (def ?name ?int))))
  47.  
  48. (define-syntax export
  49.   (syntax-rules ()
  50.     ((export ?item ...)
  51.      (really-export #f ?item ...))))
  52.  
  53. (define-syntax compound-interface
  54.   (syntax-rules ()
  55.     ((compound-interface ?int ...)
  56.      (make-compound-interface #f ?int ...))))
  57.  
  58.  
  59. ; <item> ::= <name> | (<name> <type>) | ((<name> ...) <type>)
  60.  
  61. (define-syntax export
  62.   (lambda (e r c)
  63.     (let ((items (cdr e)))
  64.       (let loop ((items items)
  65.          (plain '())
  66.          (others '()))
  67.     (if (null? items)
  68.         `(,(r 'make-simple-interface)
  69.           #f
  70.           (,(r 'list) (,(r 'quote) ,(list (reverse plain)
  71.                           ':undeclared))
  72.               ,@(reverse others)))
  73.         (let ((item (car items)))
  74.           (if (pair? item)
  75.           (loop (cdr items)
  76.             plain
  77.             (cons `(,(r 'list) (,(r 'quote) ,(car item))
  78.                        ,(cadr item))
  79.                   others))
  80.           (loop (cdr items)
  81.             (cons item plain)
  82.             others)))))))
  83.   (make-simple-interface list quote value))
  84.  
  85.             
  86. ; Structures
  87.  
  88. (define-syntax define-structure
  89.   (syntax-rules ()
  90.     ((define-structure ?name ?int ?clause1 ?clause ...)
  91.      (def ?name (structure ?int ?clause1 ?clause ...)))
  92.     ;; For compatibility.  Use DEF instead.
  93.     ((define-structure ?name ?exp)
  94.      (def ?name ?exp))))
  95.  
  96. (define-syntax define-structures
  97.   (syntax-rules ()
  98.     ((define-structures ((?name ?int) ...)
  99.        ?clause ...)
  100.      (def ?name ... (structures (?int ...) ?clause ...)))))
  101.  
  102. (define-syntax structure
  103.   (syntax-rules ()
  104.     ((structure ?int ?clause ...)
  105.      (structures (?int) ?clause ...))))
  106.  
  107. (define-syntax structures
  108.   (syntax-rules ()
  109.     ((structures (?int ...) ?clause ...)
  110.      (let ((p (a-package #f ?clause ...)))
  111.        (values (make-structure p (lambda () ?int))
  112.            ...)))))
  113.  
  114.  
  115. ; Packages
  116.  
  117. (define-syntax a-package
  118.   (let ()
  119.  
  120.     (define (parse-package-clauses clauses rename compare)
  121.       (let ((%open (rename 'open))
  122.         (%access (rename 'access))
  123.         (%for-syntax (rename 'for-syntax)))
  124.     (let loop ((clauses clauses)
  125.            (opens '())
  126.            (accesses '())
  127.            (for-syntaxes '())
  128.            (others '()))
  129.       (cond ((null? clauses)
  130.          (values opens accesses for-syntaxes (reverse others)))
  131.         ((not (list? (car clauses)))
  132.          (display "Ignoring invalid define-structures clause")
  133.          (newline)
  134.          (write (car clauses)) (newline)
  135.          (loop (cdr clauses)
  136.                opens
  137.                accesses
  138.                for-syntaxes
  139.                others))
  140.         (else
  141.          (let ((keyword (caar clauses)))
  142.            (cond ((compare keyword %open)
  143.               (loop (cdr clauses)
  144.                 (append opens (cdar clauses))
  145.                 accesses
  146.                 for-syntaxes
  147.                 others))
  148.              ((compare keyword %access)
  149.               (loop (cdr clauses)
  150.                 opens
  151.                 (append (cdar clauses) accesses)
  152.                 for-syntaxes
  153.                 others))
  154.              ((compare keyword %for-syntax)
  155.               (loop (cdr clauses)
  156.                 opens
  157.                 accesses
  158.                 (append (cdar clauses) for-syntaxes)
  159.                 others))
  160.              (else
  161.               (loop (cdr clauses)
  162.                 opens
  163.                 accesses
  164.                 for-syntaxes
  165.                 (cons (car clauses) others))))))))))
  166.  
  167.     (lambda (form rename compare)
  168.       (let ((names (cadr form))
  169.         (clauses (cddr form)))
  170.     (call-with-values (lambda ()
  171.                 (parse-package-clauses clauses rename compare))
  172.       (lambda (opens accesses for-syntaxes others)
  173.         (let ((%make (rename 'make-a-package))
  174.           (%lambda (rename 'lambda))
  175.           (%cons (rename 'cons))
  176.           (%list (rename 'list))
  177.           (%quote (rename 'quote))
  178.           (%a-package (rename 'a-package))
  179.           (%file-name (rename '%file-name%)))
  180.           `(,%make (,%lambda () (,%list ,@opens))
  181.                (,%lambda ()
  182.                (,%list ,@(map (lambda (a)
  183.                         `(,%cons (,%quote ,a) ,a))
  184.                       accesses)))
  185.                (,(string->symbol ".make-reflective-tower.")
  186.             (,%quote ,for-syntaxes)
  187.             (,%quote ,names))
  188.                (,%file-name)
  189.                (,%quote ,others)
  190.                (,%quote ,(cadr form)))))))))
  191.   (cons lambda list make-a-package quote %file-name%))
  192.  
  193.  
  194. (define-syntax receive
  195.   (syntax-rules ()
  196.     ((receive (?var ...) ?producer . ?body)
  197.      (call-with-values (lambda () ?producer)
  198.        (lambda (?var ...)
  199.      (note-name! ?var '?var) ...
  200.      (let () . ?body))))))
  201.  
  202.  
  203. ; (DEFINE-REFLECTIVE-TOWER-MAKER <proc>)
  204. ;   <proc> should be an expression that evaluates to a procedure of
  205. ;   two arguments.  The first argument is a list of DEFINE-STRUCTURE
  206. ;   clauses, and the second is some identifying information (no
  207. ;   semantic content).  The procedure should return a "reflective
  208. ;   tower", which is a pair (<eval-proc> . <env>).  To evaluate the
  209. ;   right-hand side of a DEFINE-SYNTAX (LET-SYNTAX, etc.) form,
  210. ;   <eval-proc> is called on the right-hand side and <env>.
  211. ; Got that?
  212.  
  213. (define-syntax define-reflective-tower-maker
  214.   (lambda (e r c)
  215.     `(,(r 'define) ,(string->symbol ".make-reflective-tower.") ,(cadr e)))
  216.   (define))
  217.  
  218. (define-syntax export-reflective-tower-maker
  219.   (lambda (e r c)
  220.     `(,(r 'export) ,(string->symbol ".make-reflective-tower.")))
  221.   (export))
  222.  
  223.  
  224. ; Modules  = package combinators...
  225.  
  226. (define-syntax define-module
  227.   (syntax-rules ()
  228.     ((define-module (?name . ?args) ?body ...)
  229.      (def ?name (lambda ?args ?body ...)))))
  230.